COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 QUERIO    					    -*-Mode:LispPackage:SI-*-
C00007 00003
C00015 ENDMK
C⊗;
;;; QUERIO    					    -*-Mode:Lisp;Package:SI-*-
;;; **************************************************************************
;;; ***** MACLISP ****** Build a Bi-directional SFA for Queries to User ******
;;; **************************************************************************
;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology ********
;;; ************ this is a read-only file! (all writes reserved) *************
;;; **************************************************************************


(herald QUERIO /47)


(declare (setq defmacro-for-compiling ()  defmacro-displace-call () )
	 (setq macros () ))


(defun LISPDIR macro (x)
     `(QUOTE ((LISP) ,(cadr x) #+Pdp10 FASL)))

(defun SUBLOAD macro (x)
   (setq x (cadr x))
   `(OR (GET ',x 'VERSION) (LOAD #%(lispdir ,x))))

(eval-when (eval compile)
   (subload EXTMAC)		;needed for DEFSFA
)


(defvar SI:QUERY-IO-EXTRA-OPTIONS () 
  "Used to communicate to the SFA-function whether or not there are
   certain methods in the real file arrays (CURSORPOS, RUBOUT, ??)")
(defvar SI:QUERY-IO-NEW-LISP (ALPHALESSP "2090" (STATUS LISPV))) 


(defmacro gen-query-slots (&rest l)
  (setq no-of-QUERY-IO-slots (length l))
  `(PROGN 'COMPILE 
	  ,.(do ((ll l (cdr ll)) (i 0 (1+ i)) (z))
		((null ll) z)
	      (push `(DEFMACRO ,(symbolconc '|QUERY-IO-| (car ll))  (X)
			       `(SFA-GET ,X ,,i))
		    z))))

 ;; makes things like   (defmacro QUERY-IO-input (x) `(SFA-GET ,x 1))
(gen-query-slots output input omode imode whichops bufferlist) 

(defmacro BI-DIRECTIONAL-CORRESPONDENT (x) `(SFA-GET ,x 'XCONS))

(defmacro cons-a-QUERY-IO (&rest l &aux (z (gentemp)) 
					(x (or (get l 'IN) 'TYI))
					(y (or (get l 'OUT) 'TYO))
					(in (gentemp)) 
					(out (gentemp)))
   `(LET ((,in ,x) (,out ,y) ,z)
      (SETQ SI:QUERY-IO-EXTRA-OPTIONS 
	    (APPEND (CDR (STATUS FILEMODE ,out))
		     ;; FILEPOS currently only gets you the output data
		    (DELQ 'FILEPOS (APPEND (CDR (STATUS FILEMODE ,in)) () ))))
      (SETQ ,z (SFA-CREATE 'QUERY-IO-HANDLER ,no-of-QUERY-IO-slots 'QUERY-IO))
      (SETF (QUERY-IO-output ,z) ,out)
      (SETF (QUERY-IO-input ,z) ,in)
      (SETF (QUERY-IO-omode ,z) (STATUS FILEMODE ,out))
      (SETF (QUERY-IO-imode ,z) (STATUS FILEMODE ,in))
       ;; For newer lisps, this permits the LISP toplevel routines to know
       ;;  that it's a bi-directional device, and probably the echo of a 
       ;;  <cr> inputted will suffice instead of also doing a (TERPRI).
      (AND SI:QUERY-IO-NEW-LISP 
	   (SETF (BI-DIRECTIONAL-CORRESPONDENT ,z) ,z))
      ,z))




(defun QUERY-IO-HANDLER (self op data &aux (in   (QUERY-IO-input self))
					   (out  (QUERY-IO-output self))
					   (bufl (QUERY-IO-bufferlist self)))
  (cond 
    ((eq op 'UNTYI) 
       ;; For old lisps, without the UNTYI function, we support UNTYI by just
       ;;  keeping a list of the characters sent back.  Note that we could 
       ;;  support a msg to store and retrieve this slot, and thus facilitate
       ;;  a user writing a TTYBUFFER function which could keep separate from
       ;;  the base-level TYI.
      (if (not SI:QUERY-IO-NEW-LISP) 
	  (setf (QUERY-IO-bufferlist self) (cons data bufl))
	  (untyi data in)))
    ((eq op 'TYI) 
      (if (and (not SI:QUERY-IO-NEW-LISP) bufl)
	  (progn (pop bufl data) 
		 (setf (QUERY-IO-bufferlist self) bufl)
		 data)
	  (tyi data in)))
    ((cond ((memq op '(TYO PRINT PRINC)))
	   ((memq op '(READ READLINE))
	     (setq out in)
	     'T))
       ;; Several trivial operations are just "passed down" directly to 
       ;;  the appropriate part of the sfa.
      (funcall op data out))
    ((caseq op 
	(CURSORPOS  (if (memq 'CURSORPOS (cdr (QUERY-IO-omode self)))
			(if (null data)  		  ;1-arg  ==> read pos
			    (cursorpos out)		  ;2-args ==> set pos
			    (cursorpos (car data) out))))
	(TYIPEEK    (if (and (not SI:QUERY-IO-NEW-LISP) bufl)
			(car bufl)
			(tyipeek data in -1)))
	(OPEN       (open in data) (open out data))
	(CLOSE      (close in) (close out))
	(RUBOUT     (if (memq 'RUBOUT (cdr (QUERY-IO-omode self)))
			(rubout data out)))
	(FRESH-LINE (if (and (sfap out)
			     (memq 'FRESH-LINE 
				   (sfa-call out 'WHICH-OPERATIONS () )))
			 ;; If the command can be "passed down", then do so
			(sfa-call out 'FRESH-LINE () )
			 ;; Otherwise, just try a cursorpos 'A.
			(cursorpos 'A out)))
	((CHARPOS LINEL PAGEL PAGENUM FILEPOS 
	  CLEAR-OUTPUT FORCE-OUTPUT) 
	   ;; Notice how these funtions only pay attention to the output side
	   ;;  of the bi-directional sfa.  Also, The latter 2 better have had
	   ;;  the third sfa argument ("data") sent as ().
	  (lexpr-funcall op out data))
	(LISTEN 
	  (+ (cond ((and (not SI:QUERY-IO-NEW-LISP) bufl)
		     (length bufl))
		   (0))
	     (listen in)))
	(CLEAR-INPUT 
	  (if (and (not SI:QUERY-IO-NEW-LISP) bufl) 
	      (setf (QUERY-IO-bufferlist self) () ))
	  (CLEAR-INPUT in))
	((TTY TTYSCAN TTYINT TTYTYPE TTYSIZE OSPEED TERPRI LINMOD)
	   ;; Wow, look at all these [S]STATUS options!
	   ;; Remember, 'data' = () means STATUS, otherwise a list of args 
	   ;;  for SSTATUS to use.
	   (cond ((eq op 'TERPRI) (setq in out))
		 ((not (memq op '(TTY TTYSCAN TTYINT LINMOD)))
		   (if data  
		        ;; Can't SSTATUS on TTYTYPE, TTYSIZE, OSPEED
		       (+internal-lossage 'SSTATUS 'QUERY-IO-HANDLER data))
		   (setq in out)))
	   (let ((operation-list `(,op ,@data ,in)))
	     (if data 
		 (apply #'SSTATUS operation-list)
		 (apply #'STATUS operation-list))))
	(FILEMODE 
	  ;;(status FILEMODE ...) sends () as "data", so we get the file mode
	  ;;  of the "output" side of the SFA.
	  ;;If user does (SFA-CALL <foo> 'FILEMODE 'IN), he gets input mode,
	  ;; and (SFA-CALL <foo> 'FILEMODE 'OUT) likewise gets the output mode.
	 (cond ((memq data '(() OUT))  (QUERY-IO-omode self))
	       ((eq data 'IN)          (QUERY-IO-imode self))
	       ('T (+internal-lossage 'FILEMODE 'QUERY-IO-HANDLER data))))
	 ;(TTYCONS ...)	;Is a system slot in the SFA, the "XCONS" slot and thus
			;  this status call does not send a message.
	(+INTERNAL-TTYSCAN-SUBR 
	   ;; Well, can you imagine (funcall (status ttyscan <foo>) <bar> ...)
	   ;;  so just "pass it down".
	  (+INTERNAL-TTYSCAN-SUBR in (car data) (cadr data)))
	(WHICH-OPERATIONS 
	   ;; Notice that (SFA-CALL <foo> 'WHICH-OPERATIONS <non-null-list>)
	   ;;  will store into the WHICH-OPERATIONS slot
	  (if data (setf (QUERY-IO-whichops self) data))
	  (if (null (QUERY-IO-whichops self))
	      (setf (QUERY-IO-whichops self) 
		    `(,@SI:QUERY-IO-EXTRA-OPTIONS 
		      TYI UNTYI TYIPEEK TYO READ READLINE PRINT PRINC 
		      OPEN CLOSE LISTEN CHARPOS LINEL PAGEL PAGENUM 
		      TTY TTYSCAN TTYTYPE TTYSIZE TTYINT OSPEED LINMOD 
		      FRESH-LINE CLEAR-OUTPUT FORCE-OUTPUT CLEAR-INPUT 
		      FILEMODE WHICH-OPERATIONS)))
	  (QUERY-IO-whichops self))
	(T (sfa-unclaimed-message self op data))))))


(defvar QUERY-IO 'T 
  "Where to ask questions from.  Bidirectional. SFA-form is unaffected by ↑W.")

(if (eq QUERY-IO 'T)
    (setq QUERY-IO
	  (if (status nofeature SFA) 'T ;Lossage case
	      (cons-a-QUERY-IO INPUT tyi OUTPUT tyo))))